home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Franz PD / Franz PD Disk #067 (1990-04)(Amiga User Group Deutschland e.V.).zip / Franz PD Disk #067 (1990-04)(Amiga User Group Deutschland e.V.).adf / Source.zip / Statements.p < prev    next >
Text File  |  1989-11-24  |  14KB  |  601 lines
  1. External;
  2.  
  3. {
  4.     Statements.p (of PCQ Pascal)
  5.     Copyright (c) 1989 Patrick Quaid
  6.  
  7.     This module handles normal statements, including the
  8.     standard statements like if, while, case, etc.
  9. }
  10.  
  11. {$O-}
  12. {$I "Pascal.i"}
  13.  
  14.     Function Match(s : Symbols) : Boolean;
  15.         external;
  16.     Function Expression() : TypePtr;
  17.         external;
  18.     Procedure Error(s : string);
  19.         external;
  20.     Function TypeCheck(t1, t2 : TypePtr): Boolean;
  21.         external;
  22.     Procedure SaveStack(t : TypePtr);
  23.         external;
  24.     Procedure SaveVal(v : IDPtr);
  25.         external;
  26.     Procedure ns;
  27.         external;
  28.     Procedure NextSymbol;
  29.         external;
  30.     Function GetLabel(): Integer;
  31.         external;
  32.     Procedure PrintLabel(l : integer);
  33.         external;
  34.     Function Suffix(s : Integer) : Char;
  35.         external;
  36.     Procedure Mismatch;
  37.         external;
  38.     Function LoadAddress() : TypePtr;
  39.         external;
  40.     Procedure CallProc(ProcID : IDPtr);
  41.         external;
  42.     procedure StdProc(ID : IDPtr);
  43.         external;
  44.     Function EndOfFile() : Boolean;
  45.         external;
  46.     Procedure ReadChar;
  47.         external;
  48.     Function FindID(s : string): IDPtr;
  49.         external;
  50.     Function IsVariable(i : IDPtr) : Boolean;
  51.         external;
  52.     Function ConExpr(var t : TypePtr) : integer;
  53.         external;
  54.     function BaseType(t : TypePtr) : TypePtr;
  55.         external;
  56.     Procedure PromoteType(var f : TypePtr; o : TypePtr; r : Short);
  57.         external;
  58.     Function NumberType(t : TypePtr): Boolean;
  59.         external;
  60.     Procedure PushLongD0;
  61.         external;
  62.     Procedure PushLongA0;
  63.         External;
  64.     Procedure PopStackSpace(amount : Integer);
  65.         External;
  66.     Function Selector(ID : IDPtr) : TypePtr;
  67.         external;
  68.     Function FindWithField(s : String) : IDPtr;
  69.         External;
  70.     Function CheckBreak : Boolean;
  71.         External;
  72.     Procedure Abort;
  73.         External;
  74.  
  75. Procedure Statement;
  76.     forward;
  77.  
  78. Procedure Assignment(ID : IDPtr);
  79.  
  80. {
  81.     Not surprisingly, this routine handles assignments.
  82. }
  83.  
  84. var
  85.     StackedType,
  86.     VarType,
  87.     ExprType : TypePtr;
  88.  
  89. begin
  90.     NextSymbol;
  91.     StackedType := Selector(ID);
  92.     if StackedType <> Nil then begin
  93.     PushLongA0;
  94.     VarType := StackedType;
  95.     end else
  96.     VarType := ID^.VType;
  97.     if not match(becomes1) then
  98.     error("expecting :=");
  99.     ExprType := Expression();
  100.     if TypeCheck(VarType, ExprType) then begin
  101.     PromoteType(ExprType, VarType, 0);
  102.     if StackedType <> Nil then
  103.         SaveStack(VarType)
  104.     else
  105.         SaveVal(ID);
  106.     end else
  107.     Mismatch;
  108. end;
  109.  
  110. Procedure ReturnVal;
  111.  
  112. {
  113.     This is similar to the above, but the value is left in d0.
  114. }
  115.  
  116. var
  117.     ExprType    : TypePtr;
  118. begin
  119.     nextsymbol;
  120.     if not Match(becomes1) then
  121.     error("expecting :=");
  122.     ExprType := Expression();
  123.     if not TypeCheck(CurrFn^.VType, ExprType) then
  124.     Mismatch;
  125.     if NumberType(ExprType) then
  126.     PromoteType(ExprType, CurrFn^.VType, 0);
  127.     writeln(OutFile, "\tunlk\ta5");
  128.     writeln(OutFile, "\trts");
  129. end;
  130.  
  131. Procedure DoWhile;
  132.  
  133. {
  134.     Handles the while statement.
  135. }
  136.  
  137. var
  138.     LoopLabel,
  139.     ExitLabel    : Integer;
  140. begin
  141.     LoopLabel := GetLabel();
  142.     ExitLabel := GetLabel();
  143.     PrintLabel(LoopLabel);
  144.     writeln(OutFile);
  145.     if not TypeCheck(Expression(), BoolType) then
  146.     error("Expecting boolean expression");
  147.     writeln(OutFile, "\ttst.b\td0");
  148.     write(OutFile, "\tbeq\t");
  149.     PrintLabel(ExitLabel);
  150.     writeln(OutFile);
  151.     if not Match(Do1) then
  152.     error("Missing DO");
  153.     Statement;
  154.     write(OutFile, "\tbra\t");
  155.     PrintLabel(LoopLabel);
  156.     writeln(OutFile);
  157.     PrintLabel(ExitLabel);
  158.     writeln(OutFile);
  159. end;
  160.  
  161. Procedure DoRepeat;
  162.  
  163. {
  164.     Handles the repeat statement.
  165. }
  166.  
  167. var
  168.     RepLabel    : Integer;
  169. begin
  170.     RepLabel := GetLabel();
  171.     PrintLabel(RepLabel);
  172.     writeln(OutFile);
  173.     while not Match(until1) do begin
  174.     Statement;
  175.     ns;
  176.     end;
  177.     if not TypeCheck(Expression(), Booltype) then
  178.     error("Expecting a Boolean expression.");
  179.     writeln(OutFile, "\ttst.b\td0");
  180.     write(OutFile, "\tbeq\t");
  181.     PrintLabel(RepLabel);
  182.     writeln(OutFile);
  183. end;
  184.  
  185. Procedure SaveFor(VarType : TypePtr; off : integer);
  186.  
  187. {
  188.     This routine saves the new value of the index variable for
  189. for statements.
  190. }
  191.  
  192. begin
  193.     write(OutFile, "\tmove.l\t");
  194.     if off <> 0 then
  195.     write(OutFile, off);
  196.     writeln(OutFile, '(sp),a0');
  197.     writeln(OutFile, "\tmove.", Suffix(VarType^.Size), "\td0,(a0)");
  198. end;
  199.  
  200. Procedure IncFor(VarType : TypePtr; Value : Integer);
  201.  
  202. {
  203.     This routine adjusts the index for increments of 1 or -1.
  204. }
  205.  
  206. begin
  207.     writeln(OutFile, "\tmove.l\t4(sp),a0");
  208.     writeln(OutFile, "\tadd.", Suffix(VarType^.Size), "\t#", Value,',(a0)');
  209.     writeln(OutFile, "\tmove.", Suffix(VarType^.Size), "\t(a0),d0");
  210. end;
  211.  
  212. Procedure StackInc(VarType : TypePtr);
  213.  
  214. {
  215.     This handles non-standard increments.
  216. }
  217.  
  218. begin
  219.     writeln(OutFile, "\tmove.l\t8(sp),a0");
  220.     writeln(OutFile, "\tmove.l\t(sp),d0");
  221.     writeln(OutFile, "\tadd.", Suffix(VarType^.Size), "\td0,(a0)");
  222.     writeln(OutFile, "\tmove.", suffix(VarType^.Size), "\t(a0),d0");
  223. end;
  224.  
  225. Procedure DoFor;
  226.  
  227. {
  228.     handles the for statement.
  229. }
  230.  
  231. var
  232.     looplabel    : integer;
  233.     varindex    : integer;
  234.     ByType,
  235.     VarType,
  236.     BoundType    : TypePtr;
  237.     increment    : Short;
  238.     default    : Boolean;
  239. begin
  240.     VarType := LoadAddress();
  241.     if VarType^.Object <> ob_ordinal then
  242.     error("expecting an ordinal type");
  243.     PushLongA0;
  244.     if not Match(becomes1) then
  245.     error("missing :=");
  246.     BoundType := Expression();
  247.     if not TypeCheck(VarType, BoundType) then
  248.     Mismatch;
  249.     PromoteType(BoundType, VarType, 0);
  250.     SaveFor(VarType, 0);
  251.     if Match(to1) then
  252.     increment := 1
  253.     else if Match(downto1) then
  254.     increment := -1
  255.     else
  256.     error("Expecting TO or DOWNTO");
  257.     BoundType := Expression();
  258.     if not TypeCheck(BoundType, VarType) then
  259.     Mismatch;
  260.     PromoteType(BoundType, VarType, 0);
  261.     PushLongD0;
  262.  
  263.     if Match(by1) then begin
  264.     default := false;
  265.     ByType := Expression();
  266.     if not TypeCheck(ByType, VarType) then
  267.         Mismatch;
  268.     PromoteType(ByType, VarType, 0);
  269.     PushLongD0;
  270.     end else
  271.     default := true;
  272.  
  273.     if not Match(do1) then
  274.     error("missing DO");
  275.     looplabel := GetLabel();
  276.     PrintLabel(looplabel);
  277.     writeln(OutFile);
  278.     Statement;
  279.     if default then begin
  280.     IncFor(VarType, increment);
  281.     writeln(OutFile, "\tmove.l\t(sp),d1");
  282.     end else begin
  283.     StackInc(VarType);
  284.     writeln(OutFile, "\tmove.l\t4(sp),d1");
  285.     end;
  286.     writeln(OutFile, "\tcmp.", Suffix(VarType^.Size), "\td1,d0");
  287.     if increment > 0 then
  288.     write(OutFile, "\tble\t")
  289.     else
  290.     write(OutFile, "\tbge\t");
  291.     PrintLabel(LoopLabel);
  292.     writeln(OutFile);
  293.     if default then
  294.     PopStackSpace(8)
  295.     else
  296.     PopStackSpace(12);
  297. end;
  298.  
  299. Procedure DoReturn;
  300.  
  301. {
  302.     This just takes care of return.
  303. }
  304.  
  305. begin
  306.     if CurrFn <> Nil then begin
  307.     if CurrFn^.Object = proc then begin
  308.         writeln(OutFile, "\tunlk\ta5");
  309.         writeln(OutFile, "\trts");
  310.     end else
  311.         error("return only allowed in procedures.");
  312.     end else
  313.     error("No return from the main procedure");
  314. end;
  315.  
  316. Procedure Compound;
  317.  
  318. {
  319.     This takes care of the begin...end syntax.
  320. }
  321.  
  322. begin
  323.     while not Match(end1) do begin
  324.     Statement;
  325.     if (CurrSym = Else1) or (CurrSym = Until1) then begin
  326.         Error("Expecting a statement");
  327.         NextSymbol;
  328.     end;
  329.     if CurrSym <> End1 then
  330.         ns;
  331.     end;
  332. end;
  333.  
  334. procedure DoIf;
  335.  
  336. {
  337.     This handles the if statement.  Eventually it should handle
  338. elsif.
  339. }
  340.  
  341. var
  342.     flab1, flab2    : integer;
  343. begin
  344.     flab1 := GetLabel();
  345.     if not TypeCheck(Expression(), BoolType) then
  346.     error("Expecting a Boolean type");
  347.     writeln(OutFile, "\ttst.b\td0");
  348.     write(OutFile, "\tbeq\t");
  349.     PrintLabel(flab1);
  350.     writeln(OutFile);
  351.     if not Match(then1) then
  352.     error("Missing THEN");
  353.     Statement;
  354.     if Match(else1) then begin
  355.     flab2 := getlabel();
  356.     write(OutFile, "\tbra\t");
  357.     PrintLabel(flab2);
  358.     writeln(OutFile);
  359.     PrintLabel(flab1);
  360.     writeln(OutFile);
  361.     Statement;
  362.     PrintLabel(flab2);
  363.     writeln(OutFile);
  364.     end else begin
  365.     PrintLabel(flab1);
  366.     writeln(OutFile);
  367.     end;
  368. end;
  369.  
  370. procedure DoCase;
  371.  
  372.     procedure DoRange(first, second, lab, typesize : Integer);
  373.     var
  374.     otherlabel : Integer;
  375.     begin
  376.     otherlabel := GetLabel();
  377.     writeln(OutFile, "\tcmp.", Suffix(typesize), "\t#", first, ',d0');
  378.     write(OutFile, "\tblt.s\t");
  379.     printlabel(otherlabel);
  380.     writeln(OutFile, "\n\tcmp.", Suffix(typesize), "\t#", second, ',d0');
  381.     write(OutFile, "\tble\t");
  382.     printlabel(lab);
  383.     writeln(OutFile);
  384.     printlabel(otherlabel);
  385.     writeln(OutFile);
  386.     end;
  387.  
  388.     procedure DoSingle(number, lab, typesize : Integer);
  389.     begin
  390.     writeln(OutFile, "\tcmp.", Suffix(TypeSize), "\t#", number, ',d0');
  391.     write(OutFile, "\tbeq\t");
  392.     PrintLabel(lab);
  393.     writeln(OutFile);
  394.     end;
  395.  
  396.     Procedure DoCases(ctype : TypePtr; codelabel : Integer);
  397.     var
  398.     firstnumber, secondnumber : Integer;
  399.     contype : TypePtr;
  400.     begin
  401.     while not match(colon1) do begin
  402.         firstnumber := ConExpr(ConType);
  403.         if not TypeCheck(ConType, ctype) then
  404.         Mismatch;
  405.         if Match(dotdot1) then begin
  406.         secondnumber := conexpr(contype);
  407.         if not typecheck(ctype, contype) then
  408.             mismatch;
  409.         dorange(firstnumber, secondnumber, codelabel,ctype^.Size);
  410.         end else
  411.         dosingle(firstnumber, codelabel, ctype^.size);
  412.         if currsym <> colon1 then
  413.         if not match(comma1) then
  414.             error("Expecting : or ,");
  415.     end;
  416.     end;
  417.  
  418. var
  419.     casetype : TypePtr;
  420.     outofcases, nextsetlabel, codelabel : Integer;
  421. begin
  422.     CaseType := Expression();
  423.     if CaseType^.Object <> ob_ordinal then
  424.     error("Expecting an ordinal type");
  425.     if not match(of1) then
  426.     error("Missing 'of'");
  427.     outofcases := GetLabel();
  428.     while (currsym <> end1) and (currsym <> else1) and (not endoffile()) do begin
  429.     NextSetLabel := GetLabel();
  430.     CodeLabel := GetLabel();
  431.     DoCases(CaseType, CodeLabel);
  432.     write(OutFile, "\tbra\t");
  433.     PrintLabel(NextSetLabel);
  434.     writeln(OutFile);
  435.     PrintLabel(CodeLabel);
  436.     writeln(OutFile);
  437.     Statement;
  438.     if (CurrSym <> Else1) and (CurrSym <> End1) then
  439.         ns;
  440.     write(OutFile, "\tbra\t");
  441.     PrintLabel(OutOfCases);
  442.     writeln(OutFile);
  443.     PrintLabel(NextSetLabel);
  444.     writeln(OutFile);
  445.     end;
  446.     if Match(else1) then
  447.     if CurrSym <> end1 then begin
  448.         Statement;
  449.         ns;
  450.     end;
  451.     if not Match(end1) then
  452.     Error("Expecting 'end'");
  453.     PrintLabel(outofcases);
  454.     writeln(OutFile);
  455. end;
  456.  
  457. Procedure DoWith;
  458. var
  459.     TempRec,
  460.     FirstRec : WithRecPtr;
  461.     Stay    : Boolean;
  462. begin
  463.     FirstRec := Nil;
  464.     repeat
  465.     New(TempRec);
  466.     if FirstRec = Nil then
  467.         FirstRec := TempRec;
  468.     TempRec^.Previous := FirstWith;
  469.     TempRec^.RecType := LoadAddress;
  470.     FirstWith := TempRec;
  471.     if FirstWith^.RecType^.Object <> ob_record then
  472.         Error("Expecting a record type");
  473.     PushLongA0;
  474.     FirstWith^.Offset := StackLoad;
  475.     Stay := Match(Comma1);
  476.     until not Stay;
  477.     if not Match(Do1) then
  478.     Error("Missing DO");
  479.     Statement;
  480.     repeat
  481.     Stay := FirstWith <> FirstRec;
  482.     TempRec := FirstWith^.Previous;
  483.     Dispose(FirstWith);
  484.     FirstWith := TempRec;
  485.     PopStackSpace(4);
  486.     until not Stay;
  487. end;
  488.  
  489. Procedure DoGoto;
  490. var
  491.     ID : IDPtr;
  492. begin
  493.     if CurrSym = Ident1 then begin
  494.     ID := FindID(SymText);
  495.     if ID <> Nil then begin
  496.         if ID^.Object = lab then begin
  497.         if ID^.Level = CurrentBlock^.Level then begin
  498.             Write(OutFile, '\tbra\t');
  499.             PrintLabel(ID^.Unique);
  500.             Writeln(OutFile);
  501.             NextSymbol;
  502.         end else
  503.             Error("You cannot jump out of scopes");
  504.         end else
  505.         Error("Expecting a label");
  506.     end else
  507.         Error("Unknown ID");
  508.     end else
  509.     Error("Expecting a comment");
  510. end;
  511.  
  512. Procedure Statement;
  513.  
  514. {
  515.     This is the main routine for handling statements of all
  516. sorts.  It distributes the work as necessary.
  517. }
  518.  
  519. var
  520.     VarIndex    : IDPtr;
  521. begin
  522.     if EndOfFile() then
  523.     return;
  524.     VarIndex := Nil;
  525.     if CurrSym = Ident1 then begin { Handle label prefix }
  526.     VarIndex := FindWithField(SymText);
  527.     if VarIndex = Nil then
  528.         VarIndex := FindID(SymText);
  529.     if VarIndex <> Nil then begin
  530.         if VarIndex^.Object = lab then begin
  531.         PrintLabel(VarIndex^.Unique);
  532.         Writeln(OutFile);
  533.         NextSymbol;
  534.         if not Match(Colon1) then
  535.             Error("Missing colon");
  536.         VarIndex := Nil;
  537.         end;
  538.     end else
  539.         Error("Unknown ID");
  540.     end;
  541.     if CurrSym = Ident1 then begin
  542.     if VarIndex = Nil then begin { if not Nil, we found it above }
  543.         VarIndex := FindWithField(SymText);
  544.         if VarIndex = Nil then
  545.         VarIndex := FindID(symtext);
  546.     end;
  547.     if varindex = nil then begin
  548.         error("unknown ID");
  549.         while (currsym <> semicolon1) and
  550.           (currsym <> end1) and
  551.           (currentchar <> chr(10)) do
  552.         nextsymbol;
  553.     end else if (varindex = currfn) and (currfn^.Object = func) then
  554.         returnval
  555.     else if IsVariable(VarIndex) then
  556.         assignment(varindex)
  557.     else if VarIndex^.Object = proc then
  558.         callproc(varindex)
  559.     else if VarIndex^.Object = stanproc then
  560.         stdproc(varindex)
  561.     else begin
  562.         error("expecting a variable or procedure.");
  563.         while (currsym <> semicolon1) and
  564.           (currsym <> end1) and
  565.           (currentchar <> chr(10)) do
  566.         nextsymbol;
  567.         if currsym = semicolon1 then
  568.         nextsymbol;
  569.     end;
  570.     end else if match(begin1) then begin
  571.     Compound;
  572.     end else if match(if1) then begin
  573.     DoIf;
  574.     end else if match(while1) then begin
  575.     DoWhile;
  576.     end else if match(repeat1) then begin
  577.     DoRepeat;
  578.     end else if match(for1) then begin
  579.     DoFor;
  580.     end else if match(case1) then begin
  581.     DoCase;
  582.     end else if match(return1) then begin
  583.     DoReturn;
  584.     end else if Match(With1) then begin
  585.     DoWith;
  586.     end else if Match(Goto1) then begin
  587.     DoGoto;
  588.     end else if (CurrSym <> SemiColon1) and (CurrSym <> End1) and
  589.         (CurrSym <> Else1) and (CurrSym <> Until1) then begin
  590.     Error("Expecting a statement");
  591.     while (CurrSym <> SemiColon1) and
  592.           (CurrSym <> End1) and
  593.           (CurrSym <> Else1) and
  594.           (CurrSym <> Until1) and
  595.           (currentchar <> chr(10)) do
  596.         NextSymbol;
  597.     end else
  598.     if CheckBreak then
  599.         Abort;
  600. end;
  601.